<%
'######################################################################
'## util.gethttp.asp
'## -------------------------------------------------------------------
'## Feature     :   AspBox Mvc GetHttp-Util Block
'## Version     :   v1.0
'## Author      :   Lajox(lajox@19www.com)
'## Update Date :   2011/12/28 10:16
'## Description :   AspBox Mvc GetHttp-Util Block(导出文件(Excel/Txt文件)工具拓展模块)
'######################################################################

Class Cls_Util_GetHttp

	Private s_steamName

	Private Sub Class_Initialize()
		s_steamName = AB.steamName
    End Sub

	Private Sub Class_Terminate()

	End Sub

	'设置Stream组件名称
	Public Property Let steamName(Byval str)
		s_steamName = str
	End Property

	'@ *****************************************************************************
	'@ 过程名:  Mvc.Util.GetHttp.GetHttpPage(URL, CharSet, iUserName , iPassword)
	'@ 返  回:  String (字符串) 网页源码
	'@ 作  用:  GET方式获取网页源码
	'==Param========================================================================
	'@ URL  : 字符串 # [String] 网页地址
	'@ CharSet  : 字符串 # [String] 网页编码(常见有：UTF-8 GB2312 GBK等)
	'@ iUserName  : 字符串 # [String] 登陆账户 (可能需要登陆), 无需登陆则设置值为空
	'@ iPassword  : 字符串 # [String] 密码 (可能需要登陆), 无需登陆则设置值为空
	'==DEMO=========================================================================
	'@ Mvc.Util.Use "GetHttp"
	'@ AB.C.Print Mvc.Util.GetHttp.GetHttpPage("http://s.baidu.com", "UTF-8", "", "")
	'@ *****************************************************************************

    Function GetHttpPage(Byval URL, Byval CharSet, Byval iUserName , Byval iPassword)
        Dim xmlHttp
        If URL = "" Or Len(URL)<18 Or URL = "$False$" Then
            GetHttpPage = "$False$"
            Exit Function
        End If
        Set xmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
		With xmlHttp
			.SetTimeouts 10000, 10000, 10000, 10000
			.Open "GET", URL, False, iUserName, iPassword
			.Send()
		End With
        If xmlHttp.Readystate<>4 Then
            Set xmlHttp = Nothing
            GetHttpPage = "$False$"
            Exit Function
        End If
        GetHTTPPage = bytesToBSTR(xmlHttp.responseBody, CharSet)
        Set xmlHttp = Nothing
    End Function

	'@ *****************************************************************************
	'@ 过程名:  Mvc.Util.GetHttp.PostHttpPage(PostUrl, CharSet, PostData, Referer)
	'@ 返  回:  String (字符串) 网页源码
	'@ 作  用:  POST方式获取网页源码
	'==Param========================================================================
	'@ PostUrl  : 字符串 # [String] 发送远程地址
	'@ PostData  : 字符串 # [String] 发送参数
	'@ CharSet  : 字符串 # [String] 编码类型(常见有：UTF-8 GB2312 GBK等)
	'@ RefererUrl  : 字符串 # [String] 伪造来源页面(不需要验证的可留空)
	'==DEMO=========================================================================
	'@ Mvc.Util.Use "GetHttp"
	'@ AB.C.Print Mvc.Util.GetHttp.PostHttpPage("http://s.baidu.com/login.php", "UTF-8", "", "http://s.baidu.com")
	'@ *****************************************************************************

    Function PostHttpPage(Byval PostUrl, Byval CharSet, Byval PostData, Byval RefererUrl)
        Dim xmlHttp, RetStr
		If PostUrl = "" Then Exit Function
        On Error Resume Next
        Set xmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
		With XmlHttp
			.SetTimeouts 10000, 10000, 10000, 10000
			.Open "POST", PostUrl, false
			.setRequestHeader "Content-Length", Len(PostData)
			.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
			If Not IsNull(RefererUrl) and Trim(RefererUrl) <> "" Then .setRequestHeader "Referer", RefererUrl
			.Send PostData
		End With
        If Err.Number <> 0 Then
            Set xmlHttp = Nothing
            PostHttpPage = "$False$"
            Exit Function
        End If
		On Error Goto 0
        PostHttpPage = bytesToBSTR(xmlHttp.responseBody, CharSet)
        Set xmlHttp = Nothing
    End Function

	'@ *****************************************************************************
	'@ 过程名:  Mvc.Util.GetHttp.SaveRemoteFile(RemoteURL, FileName, RefererUrl)
	'@ 返  回:  String (字符串) 网页源码
	'@ 作  用:  远程调用文件（对付防采集的，用内容页地址，没有防的留空）
	'==Param========================================================================
	'@ RemoteURL 	: 字符串 # [String] 远程文件URL
	'@ FileName 	: 字符串 # [String] 保存的本地文件名
	'@ CharSet  : 字符串 # [String] 编码类型(常见有：UTF-8 GB2312 GBK等)
	'@ RefererUrl 	: 字符串 # [String] 伪造来源页面(POST方式发送)（对付防采集的，用内容页地址，没有防的留空）
	'==DEMO=========================================================================
	'@ Mvc.Util.Use "GetHttp"
	'@ Dim isSaved : isSaved = False
	'@ isSaved = Mvc.Util.GetHttp.SaveRemoteFile("http://s.baidu.com", "data.txt", "UTF-8", "")
	'@ 'isSaved = Mvc.Util.GetHttp.SaveRemoteFile("http://s.baidu.com/login.php", "data.txt", "UTF-8", "http://s.baidu.com")
	'@ If isSaved Then AB.C.Print "保存成功" Else AB.C.Print "保存失败"
	'@ *****************************************************************************

    Function SaveRemoteFile(Byval RemoteURL, Byval FileName, Byval CharSet, Byval RefererUrl)
        On Error Resume Next
		SaveRemoteFile = False
		If RemoteURL = "" Then : SaveRemoteFile = False : Exit Function : End If
		If IsNull(FileName) Or Trim(FileName) = "" Then FileName = "data.txt"
		If IsNull(CharSet) Or Trim(CharSet) = "" Then CharSet = "UTF-8"
        Dim oSteam, Retrieval, GetRemoteData
        Set Retrieval = Server.CreateObject("Msxml2.XMLHTTP")
        'Set Retrieval = Server.CreateObject("Msxml2.ServerXMLHTTP")
		With Retrieval
			If IsNull(RefererUrl) or Trim(RefererUrl) = "" Then
				'.SetTimeouts 30000, 30000, 30000, 30000
				.Open "Get", RemoteURL, False, "", ""
				.Send
				If .Readystate<>4 Or .Status > 300 Then
					SaveRemoteFile = False
					Exit Function
				End If
			Else
				'.SetTimeouts 30000, 30000, 30000, 30000
				.Open "POST", RemoteURL, false
				.setRequestHeader "Referer", RefererUrl
				.Send ""
			End If
			GetRemoteData = .ResponseBody
		End With
        Set Retrieval = Nothing
        Set oSteam = Server.CreateObject(s_steamName)
        With oSteam
			.Type = 1
			.mode = 3
			.Open
			'.Charset = CharSet
			.Position = oSteam.Size
			.Write = GetRemoteData
			.SaveToFile Server.MapPath(FileName), 2
			.Cancel()
			.Close
        End With
        If Err.Number<>0 Then
            SaveRemoteFile = False
			On Error Goto 0
            Exit Function
        End If
        Set oSteam = Nothing
		SaveRemoteFile = True
    End Function

	'@ *****************************************************************************
	'@ 过程名:  Mvc.Util.GetHttp.GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
	'@ 返  回:  String (字符串) 截取字符串，截取失败一般返回值 $False$
	'@ 作  用:  截取字符串
	'==Param========================================================================
	'@ ConStr  : 字符串 # [String] 将要截取的字符串
	'@ StartStr  : 字符串 # [String] 开始字符串
	'@ OverStr  : 字符串 # [String] 结束字符串
	'@ IncluL  : True/False # [Boolean] 是否包含StartStr
	'@ IncluR  : True/False # [Boolean] 是否包含OverStr
	'==DEMO=========================================================================
	'@ Mvc.Util.Use "GetHttp"
	'@ AB.C.Print Mvc.Util.GetHttp.GetBody("abcdefghijklmnopqrstuvwxyz","cd","hi",False,False) '返回值: efg
	'@ *****************************************************************************

	Function GetBody(Byval ConStr, Byval StartStr, Byval OverStr, Byval IncluL, Byval IncluR)
		If ConStr = "$False$" or ConStr = "" or IsNull(ConStr) = True Or StartStr = "" or IsNull(StartStr) = True Or OverStr = "" or IsNull(OverStr) = True Then
			GetBody = "$False$"
			Exit Function
		End If
		Dim ConStrTemp
		Dim Start,Over
		ConStrTemp = Lcase(ConStr)
		StartStr = Lcase(StartStr)
		OverStr = Lcase(OverStr)
		Start  =  InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
		If Start <= 0 then
			GetBody = "$False$"
			Exit Function
		Else
			If IncluL = False Then
				Start = Start+LenB(StartStr)
			End If
		End If
		Over = InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
		If Over <= 0 Or Over <= Start then
			GetBody = "$False$"
			Exit Function
		Else
			If IncluR = True Then
				Over = Over+LenB(OverStr)
			End If
		End If
		GetBody = MidB(ConStr,Start,Over-Start)
	End Function

	'@ *****************************************************************************
	'@ 过程名:  Mvc.Util.GetHttp.GetLinkArray(ConStr,StartStr,OverStr,IncluL,IncluR)
	'@ 返  回:  String (字符串) 提取链接地址，以$Array$分隔，获取失败一般返回值 $False$
	'@ 作  用:  提取链接地址，以$Array$分隔
	'==Param========================================================================
	'@ ConStr  : 字符串 # [String] 提取地址的原字符
	'@ StartStr  : 字符串 # [String] 开始字符串
	'@ OverStr  : 字符串 # [String] 结束字符串
	'@ IncluL  : True/False # [Boolean] 是否包含StartStr
	'@ IncluR  : True/False # [Boolean] 是否包含OverStr
	'==DEMO=========================================================================
	'@ Mvc.Util.Use "GetHttp"
	'@ AB.C.Print Mvc.Util.GetHttp.GetLinkArray("abcdefghijklmnopqrstuvwxyz","cd","hi",False,False)
	'@ *****************************************************************************

	Function GetLinkArray(Byval ConStr, Byval StartStr, Byval OverStr, Byval IncluL, Byval IncluR)
		If ConStr = "$False$" or ConStr = "" Or IsNull(ConStr) = True or StartStr = "" Or OverStr = "" or  IsNull(StartStr) = True Or IsNull(OverStr) = True Then
			GetLinkArray = "$False$"
			Exit Function
		End If
		Dim temp,oReg,Matches,Match
		temp = ""
		Set oReg  =  New Regexp
		oReg.IgnoreCase  =  True
		oReg.Global  =  True
		oReg.Pattern  =  "("&StartStr&").+?("&OverStr&")"
		Set Matches  = oReg.Execute(ConStr)
		For Each Match in Matches
			temp = temp & "$Array$" & Match.Value
		Next
		Set Matches = nothing
		If temp = "" Then
			GetLinkArray = "$False$"
			Exit Function
		End If
		temp = Right(temp,Len(temp)-7)
		If IncluL = False then
			oReg.Pattern  = StartStr
			temp = oReg.Replace(temp,"")
		End if
		If IncluR = False then
			oReg.Pattern  = OverStr
			temp = oReg.Replace(temp,"")
		End if
		Set oReg = nothing
		Set Matches = nothing
		temp = Replace(temp,"""","")
		temp = Replace(temp,"'","")
		temp = Replace(temp," ","")
		temp = Replace(temp,"(","")
		temp = Replace(temp,")","")
		temp = Replace(temp,Chr(30),"$Array$")
		If temp = "" then
			GetLinkArray = "$False$"
		Else
			GetLinkArray = temp
		End if
	End Function

	'====辅助函数====

		'将获取的源码转换为中文
		Private Function BytesToBstr(Byval Body, Byval Cset)
			Dim Objstream
			Set Objstream = Server.CreateObject(s_steamName)
			With objstream
				.Type = 1
				.Mode = 3
				.Open
				.Write body
				.Position = 0
				.Type = 2
				.Charset = Cset
				BytesToBstr = objstream.ReadText
				.Close
			End With
			Set objstream = Nothing
		End Function

End Class
%>